#lang racket


(require mysterx)

(require "../base/main.rkt"
         "../proxies/main.rkt")

(provide com-object-eq?)

(provide load-autocad-com
         
         ; constants
         ac-active-viewport
         ac-all-viewports
         
         ac-intersection
         ac-subtraction
         ac-union
         
         perspective-off
         perspective-on
         
         sky-status-off
         sky-status-background
         sky-status-background-and-illumination
         
         sun-status-off
         sun-status-on
         
         vbCr
         
         optional
         
         ; object methods
         object-boolean
         object-copy
         object-delete
         object-explode
         object-get-bounding-box
         object-move
         object-offset
         object-rotate3d
         object-transform-by
         
         ; object properties
         get-object-center
         
         get-object-closed?
         set-object-closed!
         
         get-object-control-points
         get-object-elevation
         get-object-end-angle
         get-object-end-point
         get-object-handle
         get-object-material
         get-object-name
         get-object-normal
         get-object-position
         get-object-radius
         get-object-start-angle
         get-object-start-point
         
         get-object-true-color
         set-object-true-color!
         
         get-object-visible
         set-object-visible!
         
         ; 2d-polyline properties
         get-2d-polyline-coordinates
         
         ; 3d-polyline properties
         get-3d-polyline-coordinates
         
         ; ac-cm-color methods
         ac-cm-color-set-rgb!
         
         ; ac-cm-color properties
         get-ac-cm-color-blue
         get-ac-cm-color-green
         get-ac-cm-color-red
         
         ; materials methods
         materials-add
         materials-delete
         materials-item
         
         ; application methods
         application-get-interface-object
         application-get-ac-cm-color-interface-object
         
         ; application properties
         get-application-active-document
         get-application-documents
         
         ; document methods         
         ;; active document methods
         active-document-close
         active-document-end-undo-mark
         active-document-get-variable
         active-document-regen
         active-document-send-command
         active-document-set-variable!
         active-document-start-undo-mark
         
         ;; variables
         get-loft-normals-variable
         set-loft-normals-variable!
         
         get-cmd-echo-variable
         set-cmd-echo-variable!
         
         get-lens-length-variable
         set-lens-length-variable!
         
         get-loft-param-variable
         set-loft-param-variable!
         
         get-no-mutt-variable
         set-no-mutt-variable!
         
         get-perspective-variable
         set-perspective-variable!
         
         get-sky-status-variable
         set-sky-status-variable!
         
         get-sun-status-variable
         set-sun-status-variable!
         
         get-target-variable
         get-viewctr-variable
         get-viewdir-variable
         
         ; document properties
         ;; active document properties
         get-active-document-active-layer
         set-active-document-active-layer!
         
         get-active-document-layers
         get-active-document-materials
         get-active-document-views
         
         ; documents methods
         ;; active application documents methods
         active-application-documents-open
         
         ;; active document properties
         get-active-document-active-layer
         set-active-document-active-layer!
         
         get-active-document-modelspace
         
         ; layer properties
         get-layer-name
         
         ; layers methods
         ;; active document layers methods
         active-document-layers-add
         active-document-layers-item
         
         ; layers properties
         ;; active document layers count
         get-active-document-layers-count
         
         ; light-weight-polyline properties
         get-light-weight-polyline-coordinates
         
         ; modelspace methods
         ;; active modelspace methods
         add-2d-polyline
         add-3d-face
         add-3d-poly
         add-arc
         add-box
         add-circle
         add-cone
         add-cylinder
         add-ellipse
         add-extruded-solid
         add-line
         add-point
         add-region
         add-sphere
         add-spline
         add-text
         active-modelspace-item
         
         ; modelspace properties
         ;; active modelspace properties
         get-active-modelspace-count
         
         ; point properties
         get-point-coordinates
         
         ; viewport properties
         get-viewport-center
         set-viewport-center!
         get-viewport-height
         set-viewport-height!
         get-viewport-snap-on
         set-viewport-snap-on!
         get-viewport-target
         set-viewport-target!
         get-viewport-width
         set-viewport-width!)


; constants

(define ac-active-viewport 0)
(define ac-all-viewports 1)
(define ac-intersection 1)
(define ac-subtraction 2)
(define ac-union 0)

(define optional com-omit)

(define perspective-off 0)
(define perspective-on 1)

(define sky-status-off 0)
(define sky-status-background 1)
(define sky-status-background-and-illumination 2)

(define sun-status-off 0)
(define sun-status-on 1)

(define vbCr (string-append (string #\return) (string #\newline)))


; initialization

(define autocad-com-msg "Waiting for AutoCAD to be ready...")


(define (autocad-invoke . args)
  (try-exn-connection
   autocad-com-msg
   (λ () (apply com-invoke args))))

(define (autocad-get-property . args)
  (try-exn-connection
   autocad-com-msg
   (λ () (apply com-get-property args))))

(define (autocad-set-property! . args)
  (try-exn-connection
   autocad-com-msg
   (λ () (apply com-set-property! args))))


(define autocad-application #f)
(define autocad-active-document #f)
(define autocad-active-modelspace #f)


(define (load-autocad-com)
  (set! autocad-application
        (let ((coclass-name "AutoCAD Application"))
          (with-handlers ((exn?
                           (λ (e)
                             (displayln "Starting AutoCAD...")
                             (cci/coclass coclass-name))))
            (gao/coclass coclass-name)))))


; marshaling

(define (color<-ac-cm-color col)
  (let ((red (get-ac-cm-color-red col))
        (green (get-ac-cm-color-green col))
        (blue (get-ac-cm-color-blue col)))
    (color-of-rgb red green blue)))

(define (ac-cm-color<-color col)
  (let-values (((red green blue) (rgb-of-color col)))
    (let ((ac-cm-color (application-get-ac-cm-color-interface-object)))
      (ac-cm-color-set-rgb! ac-cm-color red green blue)
      ac-cm-color)))


; object methods

(define (object-boolean operation object1 object2)
  (autocad-invoke object1 "Boolean" operation object2)
  object1)

(define (object-copy object)
  (autocad-invoke object "Copy"))

(define (object-delete object)
  (autocad-invoke object "Delete"))

(define (object-explode object)
  (vector->list
   (autocad-invoke object "Explode")))

; edit: test with 'let' instead of 'define'
(define (object-get-bounding-box object)
  (define min-point (box (vector 0.0 0.0 0.0)))
  (define max-point (box (vector 0.0 0.0 0.0)))
  (autocad-invoke object "GetBoundingBox" min-point max-point)
  (make-bbox
   (box-corners-pp
    (coord-of-vector (unbox min-point))
    (coord-of-vector (unbox max-point)))))

(define (object-move object point1 point2)
  (begin0
    object
    (autocad-invoke
     object
     "Move"
     (vector<real><-coord point1)
     (vector<real><-coord point2))))

(define (object-offset object distance)
  (vector->list
   (autocad-invoke
    object
    "Offset"
    (real<-number distance))))

(define (object-rotate3d object point1 point2 rotation-angle)
  (begin0
    object
    (autocad-invoke
     object
     "Rotate3D"
     (vector<real><-coord point1)
     (vector<real><-coord point2)
     (real<-number rotation-angle))))

(define (object-transform-by object matrix)
  (begin0
    object
    (autocad-invoke
     object
     "TransformBy"
     (vector<vector<real>><-matrix matrix))))


; object properties

(define (get-object-center object)
  (coord-of-vector
   (autocad-get-property object "Center")))

(define (get-object-closed? object)
  (autocad-get-property object "Closed"))

(define (set-object-closed! object closed?)
  (autocad-set-property! object "Closed" closed?))

(define (get-object-control-points object)
  (list<coord><-flat-vector<number>
   (autocad-get-property object "ControlPoints")))

(define (get-object-elevation object)
  (autocad-get-property object "Elevation"))

(define (get-object-end-angle object)
  (autocad-get-property object "EndAngle"))

(define (get-object-end-point object)
  (coord-of-vector
   (autocad-get-property object "EndPoint")))

(define (get-object-handle object)
  (autocad-get-property object "Handle"))

(define (get-object-material object)
  (autocad-get-property object "Material"))

(define (get-object-name object)
  (autocad-get-property object "ObjectName"))

(define (get-object-normal object)
  (coord-of-vector
   (autocad-get-property object "Normal")))

(define (get-object-position object)
  (coord-of-vector
   (autocad-get-property object "Position")))

(define (get-object-radius object)
  (autocad-get-property object "Radius"))

(define (get-object-start-angle object)
  (autocad-get-property object "StartAngle"))

(define (get-object-start-point object)
  (coord-of-vector
   (autocad-get-property object "StartPoint")))


(define (get-object-true-color object)
  (color<-ac-cm-color
   (autocad-get-property object "TrueColor")))

(define (set-object-true-color! object value)
  (autocad-set-property! object "TrueColor" (ac-cm-color<-color value)))


(define (get-object-visible object)
  (autocad-get-property object "Visible"))

(define (set-object-visible! object visible?)
  (autocad-set-property! object "Visible" visible?))


; 2d-polyline properties

(define (get-2d-polyline-coordinates object)
  (list<coord><-flat-vector<number>
   (autocad-get-property object "Coordinates")))


; 3d-polyline properties

(define get-3d-polyline-coordinates get-2d-polyline-coordinates)


; ac-cm-color methods

(define (ac-cm-color-set-rgb! object red green blue)
  (autocad-invoke object "SetRGB" red green blue))


; ac-cm-color properties

(define (get-ac-cm-color-blue object)
  (autocad-get-property object "Blue"))

(define (get-ac-cm-color-green object)
  (autocad-get-property object "Green"))

(define (get-ac-cm-color-red object)
  (autocad-get-property object "Red"))


; materials methods

(define (materials-add object name)
  (autocad-invoke object "Add" name))

(define (materials-delete object name)
  (autocad-invoke object "Delete" name))

(define (materials-item object name/index)
  (autocad-invoke object "Item" name/index))


; materials properties

(define (get-materials-count materials)
  (autocad-get-property materials "Count"))


; application methods

(define (application-get-interface-object name)
  (autocad-invoke autocad-application "GetInterfaceObject" name))


(define ac-cm-color-name "AutoCAD.AcCmColor.18")

; info: avoid caching because com-objects returned by 'GetInterfaceObject' seem to
; be always different according to 'com-object-eq?'
(define (application-get-ac-cm-color-interface-object)
  (application-get-interface-object ac-cm-color-name))


; application properties

(define (get-application-active-document)
  (if autocad-active-document
      autocad-active-document
      (let ((active-document (autocad-get-property autocad-application "ActiveDocument")))
        (set! autocad-active-document active-document)
        active-document)))

(define (get-application-documents application)
  (autocad-get-property application "Documents"))


; document methods

(define (document-close document save-changes?)
  (autocad-invoke document "Close" save-changes?))

(define (document-end-undo-mark document)
  (autocad-invoke document "EndUndoMark"))

(define (document-get-variable document name)
  (autocad-invoke document "GetVariable" name))

(define (document-regen document viewport)
  (autocad-invoke document "Regen" viewport))

(define (document-send-command document command)
  (autocad-invoke document "SendCommand" command))

(define (document-set-variable! document name value)
  (autocad-invoke document "SetVariable" name value))

(define (document-start-undo-mark document)
  (autocad-invoke document "StartUndoMark"))


;; variables

;;; loft normals

(define loft-normals-name "LOFTNORMALS")

(define (loft-normals-type s)
  (case s
    ('ruled 0)
    ('smooth-fit 1)
    ('start-cross-section 2)
    ('end-cross-section 3)
    ('start-and-end-cross-section 4)
    ('all-cross-sections 5)
    ('use-draft-angle-and-magniture 6)
    (else (error 'loft-normals-type "Unhandled loft normals type"))))

(define (loft-normals-type-rev s)
  (case s
    ((0) 'ruled)
    ((1) 'smooth-fit)
    ((2) 'start-cross-section)
    ((3) 'end-cross-section)
    ((4) 'start-and-end-cross-section)
    ((5) 'all-cross-sections)
    ((6) 'use-draft-angle-and-magniture)
    (else (error 'loft-normals-type-rev "Unhandled loft normals type"))))

(define (get-loft-normals-variable)
  (loft-normals-type-rev (active-document-get-variable loft-normals-name)))

(define (set-loft-normals-variable! value)
  (active-document-set-variable! loft-normals-name (loft-normals-type value)))


;;; loft ang1

(define loft-ang1-name "LOFTANG1")

(define (get-loft-ang1-variable)
  (active-document-get-variable loft-ang1-name))

(define (set-loft-ang1-variable value)
  (active-document-set-variable! loft-ang1-name value))


;;; loft ang2

(define loft-ang2-name "LOFTANG2")

(define (get-loft-ang2-variable)
  (active-document-get-variable loft-ang2-name))

(define (set-loft-ang2-variable! value)
  (active-document-set-variable! loft-ang2-name value))


;;; loft mag1

(define loft-mag1-name "LOFTMAG1")

(define (get-loft-mag1-variable)
  (active-document-get-variable loft-mag1-name))

(define (set-loft-mag1-variable! value)
  (active-document-set-variable! loft-mag1-name value))


;;; loft mag2

(define loft-mag2-name "LOFTMAG2")

(define (get-loft-mag2-variable)
  (active-document-get-variable loft-mag2-name))

(define (set-loft-mag2-variable! value)
  (active-document-set-variable! loft-mag2-name value))


;;; cmd echo

(define cmd-echo-name "CMDECHO")

(define (get-cmd-echo-variable)
  (active-document-get-variable cmd-echo-name))

(define (set-cmd-echo-variable! value)
  (active-document-set-variable! cmd-echo-name value))


; lens length

(define lens-length-name "LENSLENGTH")

(define (get-lens-length-variable)
  (active-document-get-variable lens-length-name))

(define (set-lens-length-variable! value)
  (active-document-set-variable! lens-length-name value))


;;; loft param

(define loft-param-name "LOFTPARAM")

(define (loft-param-type s)
  (case s
    ((no-twist) 1)
    ((align-direction) 2)
    ((simplify) 4)
    ((close) 8)
    (else (error 'loft-param-type "Unhandled loft param type"))))

(define (loft-param-type-rev s)
  (case s
    ((1) '(no-twist))
    ((2) '(align-direction))
    ((3) '(no-twist align-direction))
    ((4) '(simplify))
    ((5) '(no-twist simplify))
    ((6) '(align-direction simplify))
    ((7) '(no-twist align-direction simplify))
    ((8) '(close))
    ((9) '(no-twist close))
    ((10) '(align-direction close))
    ((11) '(no-twist align-direction close))
    ((12) '(simplify close))
    ((13) '(no-twist simplify close))
    ((14) '(align-direction simplify close))
    ((15) '(no-twist align-direction simplify close))
    (else (error 'loft-param-type-rev "Unhandled loft param type"))))

(define (get-loft-param-variable)
  (loft-param-type-rev (active-document-get-variable loft-param-name)))

(define (set-loft-param-variable! value)
  (active-document-set-variable! loft-param-name (reduce + (map loft-param-type value))))


;;; no mutt

(define no-mutt-name "NOMUTT")

(define (get-no-mutt-variable)
  (active-document-get-variable no-mutt-name))

(define (set-no-mutt-variable! value)
  (active-document-set-variable! no-mutt-name value))


;;; perspective

(define perspective-name "PERSPECTIVE")

(define (get-perspective-variable)
  (active-document-get-variable perspective-name))

(define (set-perspective-variable! value)
  (active-document-set-variable! perspective-name value))


;;; sky status

(define sky-status-name "SKYSTATUS")

(define (get-sky-status-variable)
  (active-document-get-variable sky-status-name))

(define (set-sky-status-variable! value)
  (active-document-set-variable! sky-status-name value))


;;; sun status

(define sun-status-name "SUNSTATUS")

(define (get-sun-status-variable)
  (active-document-get-variable sun-status-name))

(define (set-sun-status-variable! value)
  (active-document-set-variable! sun-status-name value))


;;; target

(define target-name "TARGET")

(define (get-target-variable)
  (coord-of-vector
   (active-document-get-variable target-name)))


;;; view ctr

(define view-ctr-name "VIEWCTR")

(define (get-viewctr-variable)
  (coord-of-vector
   (active-document-get-variable view-ctr-name)))


;;; view dir

(define view-dir-name "VIEWDIR")

(define (get-viewdir-variable)
  (coord-of-vector
   (active-document-get-variable view-dir-name)))


;; active document methods

(define (active-document-close save-changes?)
  (begin0
    (document-close (get-application-active-document) save-changes?)
    (set! autocad-active-document #f)
    (set! autocad-active-modelspace #f)))

(define (active-document-end-undo-mark)
  (document-end-undo-mark (get-application-active-document)))

(define (active-document-get-variable name)
  (document-get-variable (get-application-active-document) name))

(define (active-document-regen viewport)
  (document-regen (get-application-active-document) viewport))

(define (active-document-send-command command)
  (document-send-command (get-application-active-document) command))

(define (active-document-set-variable! name value)
  (document-set-variable! (get-application-active-document) name value))

(define (active-document-start-undo-mark)
  (document-start-undo-mark (get-application-active-document)))


; document properties

(define (get-document-active-layer document) (autocad-get-property document "ActiveLayer"))
(define (set-document-active-layer! document layer) (autocad-set-property! document "ActiveLayer" layer))

(define (get-document-active-viewport document) (autocad-get-property document "ActiveViewport"))
(define (get-document-layers document) (autocad-get-property document "Layers"))
(define (get-document-materials document) (autocad-get-property document "Materials"))
(define (get-document-modelspace document) (autocad-get-property document "ModelSpace"))
(define (get-document-views document) (autocad-get-property document "Views"))


;; active document properties

(define (get-active-document-active-layer) (get-document-active-layer (get-application-active-document)))
(define (set-active-document-active-layer! layer) (set-document-active-layer! (get-application-active-document) layer))

(define (get-active-document-layers) (get-document-layers (get-application-active-document)))
(define (get-active-document-materials) (get-document-materials (get-application-active-document)))

(define (get-active-document-modelspace)
  (if autocad-active-modelspace
      autocad-active-modelspace
      (let ((modelspace (get-document-modelspace (get-application-active-document))))
        (set! autocad-active-modelspace modelspace)
        modelspace)))

(define (get-active-document-views) (get-document-views (get-application-active-document)))


; documents methods

(define (documents-open documents name)
  (autocad-invoke documents "Open" name))


;; active application documents methods

(define (active-application-documents-open name)
  (begin0
    (documents-open (get-application-documents autocad-application) name)
    (set! autocad-active-document #f)
    (set! autocad-active-modelspace #f)))


; layer properties

(define (get-layer-name object)
  (autocad-get-property object "Name"))


; layers methods

(define (layers-add layers name)
  (autocad-invoke layers "Add" name))

(define (layers-item layers name)
  (with-handlers ((exn? (λ (e) #f)))
    (autocad-invoke layers "Item" name)))


;; active document layers methods

(define (active-document-layers-add name)
  (layers-add (get-active-document-layers) name))

(define (active-document-layers-item name)
  (layers-item (get-active-document-layers) name))


; layers properties

(define (get-layers-count layers)
  (autocad-get-property layers "Count"))


;; active document layers properties

(define (get-active-document-layers-count)
  (get-layers-count (get-active-document-layers)))


; light-weight-polyline properties

; info: the fix 'list<coord><-flat-vector<number>-z' makes this function
; different from the actual AutoCAD API
(define (get-light-weight-polyline-coordinates object)
  (list<coord><-flat-vector<number>-z
   (autocad-get-property object "Coordinates")
   0))


; modelspace methods

(define (modelspace-item modelspace index)
  (autocad-invoke modelspace "Item" index))


;; active modelspace methods

(define (add-2d-polyline vertices)
  (autocad-invoke
   (get-active-document-modelspace)
   "AddPolyline"
   (flat-vector<real><-list<coord> vertices)))

; info: the last coord must be repeated to define 3-coord faces
(define add-3d-face
  (case-lambda
    ((point1 point2 point3)
     (add-3d-face point1 point2 point3 point3))
    ((point1 point2 point3 point4)
     (autocad-invoke
      (get-active-document-modelspace)
      "Add3DFace"
      (vector<real><-coord point1)
      (vector<real><-coord point2)
      (vector<real><-coord point3)
      (vector<real><-coord point4)))))

(define (add-3d-poly points)
  (autocad-invoke
   (get-active-document-modelspace)
   "Add3DPoly"
   (flat-vector<real><-list<coord> points)))

(define (add-arc center radius start-angle end-angle)
  (autocad-invoke
   (get-active-document-modelspace)
   "AddArc"
   (vector<real><-coord center)
   (real<-number radius)
   (real<-number start-angle)
   (real<-number end-angle)))

(define (add-box origin length width height)
  (autocad-invoke
   (get-active-document-modelspace)
   "AddBox"
   (vector<real><-coord origin)
   (real<-number length)
   (real<-number width)
   (real<-number height)))

(define (add-circle center radius)
  (autocad-invoke
   (get-active-document-modelspace)
   "AddCircle"
   (vector<real><-coord center)
   (real<-number radius)))

(define (add-cone center base-radius height)
  (autocad-invoke
   (get-active-document-modelspace)
   "AddCone"
   (vector<real><-coord center)
   (real<-number base-radius)
   (real<-number height)))

(define (add-cylinder center radius height)
  (autocad-invoke
   (get-active-document-modelspace)
   "AddCylinder"
   (vector<real><-coord center)
   (real<-number radius)
   (real<-number height)))

(define (add-ellipse center major-axis radius-ratio)
  (autocad-invoke
   (get-active-document-modelspace)
   "AddEllipse"
   (vector<real><-coord center)
   (vector<real><-coord major-axis)
   (real<-number radius-ratio)))

(define (add-extruded-solid profile height taper-angle)
  (autocad-invoke
   (get-active-document-modelspace)
   "AddExtrudedSolid"
   profile
   (real<-number height)
   (real<-number taper-angle)))

; edit: not used?
;; (define (add-light-weight-polyline vertices)
;;   (autocad-invoke
;;    (get-active-document-modelspace)
;;    "AddLightWeightPolyline"
;;    vertices))

(define (add-line start-point end-point)
  (autocad-invoke
   (get-active-document-modelspace)
   "AddLine"
   (vector<real><-coord start-point)
   (vector<real><-coord end-point)))

(define (add-point point)
  (autocad-invoke
   (get-active-document-modelspace)
   "AddPoint"
   (vector<real><-coord point)))

(define (add-region shapes)
  (vector->list
   (autocad-invoke
    (get-active-document-modelspace)
    "AddRegion"
    (list->vector shapes))))

(define (add-sphere center radius)
  (autocad-invoke
   (get-active-document-modelspace)
   "AddSphere"
   (vector<real><-coord center)
   (real<-number radius)))

(define (add-spline points start-tangent end-tangent)
  (autocad-invoke
   (get-active-document-modelspace)
   "AddSpline"
   (flat-vector<real><-list<coord> points)
   (vector<real><-coord start-tangent)
   (vector<real><-coord end-tangent)))

(define (add-text str insertion-point height)
  (autocad-invoke
   (get-active-document-modelspace)
   "AddText"
   str
   (vector<real><-coord insertion-point)
   (real<-number height)))

(define (active-modelspace-item index)
  (modelspace-item (get-active-document-modelspace) index))


; modelspace properties

(define (get-modelspace-count modelspace)
  (autocad-get-property modelspace "Count"))


;; active modelspace properties

(define (get-active-modelspace-count)
  (get-modelspace-count (get-active-document-modelspace)))


; point properties

(define (get-point-coordinates object)
  (coord-of-vector
   (autocad-get-property object "Coordinates")))


; viewport

;; viewport properties

(define (get-viewport-center viewport)
  (coord-of-vector
   (autocad-get-property viewport "Center")))

(define (set-viewport-center! viewport center)
  (autocad-set-property! viewport "Center" (vector<real><-coord center)))


(define (get-viewport-height viewport)
  (autocad-get-property viewport "Height"))

(define (set-viewport-height! viewport height)
  (autocad-set-property! viewport "Height" height))


(define (get-viewport-snap-on viewport)
  (autocad-get-property viewport "SnapOn"))

(define (set-viewport-snap-on! viewport snap-on?)
  (autocad-set-property! viewport "SnapOn" snap-on?))


(define (get-viewport-target viewport)
  (coord-of-vector
   (autocad-get-property viewport "Target")))

(define (set-viewport-target! viewport target)
  (autocad-set-property! viewport "Target" (vector<real><-coord target)))


(define (get-viewport-width viewport)
  (autocad-get-property viewport "Width"))

(define (set-viewport-width! viewport width)
  (autocad-set-property! viewport "Width" width))